home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / tcltk / tcl8.4 / init.tcl < prev    next >
Text File  |  2009-04-29  |  23KB  |  747 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # RCS: @(#) $Id: init.tcl,v 1.55.2.7 2007/07/05 18:03:45 dgp Exp $
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10. # Copyright (c) 1998-1999 Scriptics Corporation.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15.  
  16. if {[info commands package] == ""} {
  17.     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
  18. }
  19. package require -exact Tcl 8.4
  20.  
  21. # Compute the auto path to use in this interpreter.
  22. # The values on the path come from several locations:
  23. #
  24. # The environment variable TCLLIBPATH
  25. #
  26. # tcl_library, which is the directory containing this init.tcl script.
  27. # tclInitScript.h searches around for the directory containing this
  28. # init.tcl and defines tcl_library to that location before sourcing it.
  29. #
  30. # The parent directory of tcl_library. Adding the parent
  31. # means that packages in peer directories will be found automatically.
  32. #
  33. # Also add the directory ../lib relative to the directory where the
  34. # executable is located.  This is meant to find binary packages for the
  35. # same architecture as the current executable.
  36. #
  37. # tcl_pkgPath, which is set by the platform-specific initialization routines
  38. #    On UNIX it is compiled in
  39. #       On Windows, it is not used
  40. #    On Macintosh it is "Tool Command Language" in the Extensions folder
  41.  
  42. if {![info exists auto_path]} {
  43.     if {[info exists env(TCLLIBPATH)]} {
  44.     set auto_path $env(TCLLIBPATH)
  45.     } else {
  46.     set auto_path ""
  47.     }
  48. }
  49. namespace eval tcl {
  50.     variable Dir
  51.     if {[info library] ne ""} {
  52.     foreach Dir [list [info library]] {
  53.         if {[lsearch -exact $::auto_path $Dir] < 0} {
  54.         lappend ::auto_path $Dir
  55.         }
  56.     }
  57.     }
  58.     set Dir [file join [file dirname [file dirname \
  59.         [info nameofexecutable]]] lib]
  60.     if {[lsearch -exact $::auto_path $Dir] < 0} {
  61.     lappend ::auto_path $Dir
  62.     }
  63.     if {[info exists ::tcl_pkgPath]} {
  64.     foreach Dir $::tcl_pkgPath {
  65.         if {[lsearch -exact $::auto_path $Dir] < 0} {
  66.         lappend ::auto_path $Dir
  67.         }
  68.     }
  69.     }
  70. }
  71.   
  72. # Windows specific end of initialization
  73.  
  74. if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} {
  75.     namespace eval tcl {
  76.     proc EnvTraceProc {lo n1 n2 op} {
  77.         set x $::env($n2)
  78.         set ::env($lo) $x
  79.         set ::env([string toupper $lo]) $x
  80.     }
  81.     proc InitWinEnv {} {
  82.         global env tcl_platform
  83.         foreach p [array names env] {
  84.         set u [string toupper $p]
  85.         if {$u ne $p} {
  86.             switch -- $u {
  87.             COMSPEC -
  88.             PATH {
  89.                 if {![info exists env($u)]} {
  90.                 set env($u) $env($p)
  91.                 }
  92.                 trace add variable env($p) write \
  93.                     [namespace code [list EnvTraceProc $p]]
  94.                 trace add variable env($u) write \
  95.                     [namespace code [list EnvTraceProc $p]]
  96.             }
  97.             }
  98.         }
  99.         }
  100.         if {![info exists env(COMSPEC)]} {
  101.         if {$tcl_platform(os) eq "Windows NT"} {
  102.             set env(COMSPEC) cmd.exe
  103.         } else {
  104.             set env(COMSPEC) command.com
  105.         }
  106.         }
  107.     }
  108.     InitWinEnv
  109.     }
  110. }
  111.  
  112. # Setup the unknown package handler
  113.  
  114. package unknown tclPkgUnknown
  115.  
  116. if {![interp issafe]} {
  117.     # setup platform specific unknown package handlers
  118.     if {$::tcl_platform(platform) eq "unix"
  119.         && $::tcl_platform(os) eq "Darwin"} {
  120.     package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
  121.     }
  122.     if {$::tcl_platform(platform) eq "macintosh"} {
  123.     package unknown [list tcl::MacPkgUnknown [package unknown]]
  124.     }
  125. }
  126.  
  127. # Conditionalize for presence of exec.
  128.  
  129. if {[namespace which -command exec] eq ""} {
  130.  
  131.     # Some machines, such as the Macintosh, do not have exec. Also, on all
  132.     # platforms, safe interpreters do not have exec.
  133.  
  134.     set auto_noexec 1
  135. }
  136. set errorCode ""
  137. set errorInfo ""
  138.  
  139. # Define a log command (which can be overwitten to log errors
  140. # differently, specially when stderr is not available)
  141.  
  142. if {[namespace which -command tclLog] eq ""} {
  143.     proc tclLog {string} {
  144.     catch {puts stderr $string}
  145.     }
  146. }
  147.  
  148. # unknown --
  149. # This procedure is called when a Tcl command is invoked that doesn't
  150. # exist in the interpreter.  It takes the following steps to make the
  151. # command available:
  152. #
  153. #    1. See if the command has the form "namespace inscope ns cmd" and
  154. #       if so, concatenate its arguments onto the end and evaluate it.
  155. #    2. See if the autoload facility can locate the command in a
  156. #       Tcl script file.  If so, load it and execute it.
  157. #    3. If the command was invoked interactively at top-level:
  158. #        (a) see if the command exists as an executable UNIX program.
  159. #        If so, "exec" the command.
  160. #        (b) see if the command requests csh-like history substitution
  161. #        in one of the common forms !!, !<number>, or ^old^new.  If
  162. #        so, emulate csh's history substitution.
  163. #        (c) see if the command is a unique abbreviation for another
  164. #        command.  If so, invoke the command.
  165. #
  166. # Arguments:
  167. # args -    A list whose elements are the words of the original
  168. #        command, including the command name.
  169.  
  170. proc unknown args {
  171.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  172.     global errorCode errorInfo
  173.  
  174.     # If the command word has the form "namespace inscope ns cmd"
  175.     # then concatenate its arguments onto the end and evaluate it.
  176.  
  177.     set cmd [lindex $args 0]
  178.     if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
  179.         set arglist [lrange $args 1 end]
  180.     set ret [catch {uplevel 1 ::$cmd $arglist} result]
  181.         if {$ret == 0} {
  182.             return $result
  183.         } else {
  184.         return -code $ret -errorcode $errorCode $result
  185.         }
  186.     }
  187.  
  188.     # Save the values of errorCode and errorInfo variables, since they
  189.     # may get modified if caught errors occur below.  The variables will
  190.     # be restored just before re-executing the missing command.
  191.  
  192.     # Safety check in case something unsets the variables 
  193.     # ::errorInfo or ::errorCode.  [Bug 1063707]
  194.     if {![info exists errorCode]} {
  195.     set errorCode ""
  196.     }
  197.     if {![info exists errorInfo]} {
  198.     set errorInfo ""
  199.     }
  200.     set savedErrorCode $errorCode
  201.     set savedErrorInfo $errorInfo
  202.     set name $cmd
  203.     if {![info exists auto_noload]} {
  204.     #
  205.     # Make sure we're not trying to load the same proc twice.
  206.     #
  207.     if {[info exists unknown_pending($name)]} {
  208.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  209.     }
  210.     set unknown_pending($name) pending;
  211.     set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg]
  212.     unset unknown_pending($name);
  213.     if {$ret != 0} {
  214.         append errorInfo "\n    (autoloading \"$name\")"
  215.         return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
  216.     }
  217.     if {![array size unknown_pending]} {
  218.         unset unknown_pending
  219.     }
  220.     if {$msg} {
  221.         set errorCode $savedErrorCode
  222.         set errorInfo $savedErrorInfo
  223.         set code [catch {uplevel 1 $args} msg]
  224.         if {$code ==  1} {
  225.         #
  226.         # Compute stack trace contribution from the [uplevel].
  227.         # Note the dependence on how Tcl_AddErrorInfo, etc. 
  228.         # construct the stack trace.
  229.         #
  230.         set cinfo $args
  231.         set ellipsis ""
  232.         while {[string bytelength $cinfo] > 150} {
  233.             set cinfo [string range $cinfo 0 end-1]
  234.             set ellipsis "..."
  235.         }
  236.         append cinfo $ellipsis "\"\n    (\"uplevel\" body line 1)"
  237.         append cinfo "\n    invoked from within"
  238.         append cinfo "\n\"uplevel 1 \$args\""
  239.         #
  240.         # Try each possible form of the stack trace
  241.         # and trim the extra contribution from the matching case
  242.         #
  243.         set expect "$msg\n    while executing\n\"$cinfo"
  244.         if {$errorInfo eq $expect} {
  245.             #
  246.             # The stack has only the eval from the expanded command
  247.             # Do not generate any stack trace here.
  248.             #
  249.             return -code error -errorcode $errorCode $msg
  250.         }
  251.         #
  252.         # Stack trace is nested, trim off just the contribution
  253.         # from the extra "eval" of $args due to the "catch" above.
  254.         #
  255.         set expect "\n    invoked from within\n\"$cinfo"
  256.         set exlen [string length $expect]
  257.         set eilen [string length $errorInfo]
  258.         set i [expr {$eilen - $exlen - 1}]
  259.         set einfo [string range $errorInfo 0 $i]
  260.         #
  261.         # For now verify that $errorInfo consists of what we are about
  262.         # to return plus what we expected to trim off.
  263.         #
  264.         if {$errorInfo ne "$einfo$expect"} {
  265.             error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
  266.             [list CORE UNKNOWN BADTRACE $expect $errorInfo]
  267.         }
  268.         return -code error -errorcode $errorCode \
  269.             -errorinfo $einfo $msg
  270.         } else {
  271.         return -code $code $msg
  272.         }
  273.     }
  274.     }
  275.  
  276.     if {([info level] == 1) && [info script] eq "" \
  277.         && [info exists tcl_interactive] && $tcl_interactive} {
  278.     if {![info exists auto_noexec]} {
  279.         set new [auto_execok $name]
  280.         if {$new ne ""} {
  281.         set errorCode $savedErrorCode
  282.         set errorInfo $savedErrorInfo
  283.         set redir ""
  284.         if {[namespace which -command console] eq ""} {
  285.             set redir ">&@stdout <@stdin"
  286.         }
  287.         return [uplevel 1 exec $redir $new [lrange $args 1 end]]
  288.         }
  289.     }
  290.     set errorCode $savedErrorCode
  291.     set errorInfo $savedErrorInfo
  292.     if {$name eq "!!"} {
  293.         set newcmd [history event]
  294.     } elseif {[regexp {^!(.+)$} $name -> event]} {
  295.         set newcmd [history event $event]
  296.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
  297.         set newcmd [history event -1]
  298.         catch {regsub -all -- $old $newcmd $new newcmd}
  299.     }
  300.     if {[info exists newcmd]} {
  301.         tclLog $newcmd
  302.         history change $newcmd 0
  303.         return [uplevel 1 $newcmd]
  304.     }
  305.  
  306.     set ret [catch {set candidates [info commands $name*]} msg]
  307.     if {$name eq "::"} {
  308.         set name ""
  309.     }
  310.     if {$ret != 0} {
  311.         return -code $ret -errorcode $errorCode \
  312.         "error in unknown while checking if \"$name\" is\
  313.         a unique command abbreviation:\n$msg"
  314.     }
  315.     # Filter out bogus matches when $name contained
  316.     # a glob-special char [Bug 946952]
  317.     if {$name eq ""} {
  318.         # Handle empty $name separately due to strangeness
  319.         # in [string first] (See RFE 1243354)
  320.         set cmds $candidates
  321.     } else {
  322.         set cmds [list]
  323.         foreach x $candidates {
  324.         if {[string first $name $x] == 0} {
  325.             lappend cmds $x
  326.         }
  327.         }
  328.     }
  329.     if {[llength $cmds] == 1} {
  330.         return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
  331.     }
  332.     if {[llength $cmds]} {
  333.         return -code error "ambiguous command name \"$name\": [lsort $cmds]"
  334.     }
  335.     }
  336.     return -code error "invalid command name \"$name\""
  337. }
  338.  
  339. # auto_load --
  340. # Checks a collection of library directories to see if a procedure
  341. # is defined in one of them.  If so, it sources the appropriate
  342. # library file to create the procedure.  Returns 1 if it successfully
  343. # loaded the procedure, 0 otherwise.
  344. #
  345. # Arguments: 
  346. # cmd -            Name of the command to find and load.
  347. # namespace (optional)  The namespace where the command is being used - must be
  348. #                       a canonical namespace as returned [namespace current]
  349. #                       for instance. If not given, namespace current is used.
  350.  
  351. proc auto_load {cmd {namespace {}}} {
  352.     global auto_index auto_oldpath auto_path
  353.  
  354.     if {$namespace eq ""} {
  355.     set namespace [uplevel 1 [list ::namespace current]]
  356.     }
  357.     set nameList [auto_qualify $cmd $namespace]
  358.     # workaround non canonical auto_index entries that might be around
  359.     # from older auto_mkindex versions
  360.     lappend nameList $cmd
  361.     foreach name $nameList {
  362.     if {[info exists auto_index($name)]} {
  363.         namespace eval :: $auto_index($name)
  364.         # There's a couple of ways to look for a command of a given
  365.         # name.  One is to use
  366.         #    info commands $name
  367.         # Unfortunately, if the name has glob-magic chars in it like *
  368.         # or [], it may not match.  For our purposes here, a better
  369.         # route is to use 
  370.         #    namespace which -command $name
  371.         if {[namespace which -command $name] ne ""} {
  372.         return 1
  373.         }
  374.     }
  375.     }
  376.     if {![info exists auto_path]} {
  377.     return 0
  378.     }
  379.  
  380.     if {![auto_load_index]} {
  381.     return 0
  382.     }
  383.     foreach name $nameList {
  384.     if {[info exists auto_index($name)]} {
  385.         namespace eval :: $auto_index($name)
  386.         if {[namespace which -command $name] ne ""} {
  387.         return 1
  388.         }
  389.     }
  390.     }
  391.     return 0
  392. }
  393.  
  394. # auto_load_index --
  395. # Loads the contents of tclIndex files on the auto_path directory
  396. # list.  This is usually invoked within auto_load to load the index
  397. # of available commands.  Returns 1 if the index is loaded, and 0 if
  398. # the index is already loaded and up to date.
  399. #
  400. # Arguments: 
  401. # None.
  402.  
  403. proc auto_load_index {} {
  404.     global auto_index auto_oldpath auto_path errorInfo errorCode
  405.  
  406.     if {[info exists auto_oldpath] && $auto_oldpath eq $auto_path} {
  407.     return 0
  408.     }
  409.     set auto_oldpath $auto_path
  410.  
  411.     # Check if we are a safe interpreter. In that case, we support only
  412.     # newer format tclIndex files.
  413.  
  414.     set issafe [interp issafe]
  415.     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  416.     set dir [lindex $auto_path $i]
  417.     set f ""
  418.     if {$issafe} {
  419.         catch {source [file join $dir tclIndex]}
  420.     } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
  421.         continue
  422.     } else {
  423.         set error [catch {
  424.         set id [gets $f]
  425.         if {$id eq "# Tcl autoload index file, version 2.0"} {
  426.             eval [read $f]
  427.         } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
  428.             while {[gets $f line] >= 0} {
  429.             if {[string index $line 0] eq "#" 
  430.                 || ([llength $line] != 2)} {
  431.                 continue
  432.             }
  433.             set name [lindex $line 0]
  434.             set auto_index($name) \
  435.                 "source [file join $dir [lindex $line 1]]"
  436.             }
  437.         } else {
  438.             error "[file join $dir tclIndex] isn't a proper Tcl index file"
  439.         }
  440.         } msg]
  441.         if {$f ne ""} {
  442.         close $f
  443.         }
  444.         if {$error} {
  445.         error $msg $errorInfo $errorCode
  446.         }
  447.     }
  448.     }
  449.     return 1
  450. }
  451.  
  452. # auto_qualify --
  453. #
  454. # Compute a fully qualified names list for use in the auto_index array.
  455. # For historical reasons, commands in the global namespace do not have leading
  456. # :: in the index key. The list has two elements when the command name is
  457. # relative (no leading ::) and the namespace is not the global one. Otherwise
  458. # only one name is returned (and searched in the auto_index).
  459. #
  460. # Arguments -
  461. # cmd        The command name. Can be any name accepted for command
  462. #               invocations (Like "foo::::bar").
  463. # namespace    The namespace where the command is being used - must be
  464. #               a canonical namespace as returned by [namespace current]
  465. #               for instance.
  466.  
  467. proc auto_qualify {cmd namespace} {
  468.  
  469.     # count separators and clean them up
  470.     # (making sure that foo:::::bar will be treated as foo::bar)
  471.     set n [regsub -all {::+} $cmd :: cmd]
  472.  
  473.     # Ignore namespace if the name starts with ::
  474.     # Handle special case of only leading ::
  475.  
  476.     # Before each return case we give an example of which category it is
  477.     # with the following form :
  478.     # ( inputCmd, inputNameSpace) -> output
  479.  
  480.     if {[string match ::* $cmd]} {
  481.     if {$n > 1} {
  482.         # ( ::foo::bar , * ) -> ::foo::bar
  483.         return [list $cmd]
  484.     } else {
  485.         # ( ::global , * ) -> global
  486.         return [list [string range $cmd 2 end]]
  487.     }
  488.     }
  489.     
  490.     # Potentially returning 2 elements to try  :
  491.     # (if the current namespace is not the global one)
  492.  
  493.     if {$n == 0} {
  494.     if {$namespace eq "::"} {
  495.         # ( nocolons , :: ) -> nocolons
  496.         return [list $cmd]
  497.     } else {
  498.         # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
  499.         return [list ${namespace}::$cmd $cmd]
  500.     }
  501.     } elseif {$namespace eq "::"} {
  502.     #  ( foo::bar , :: ) -> ::foo::bar
  503.     return [list ::$cmd]
  504.     } else {
  505.     # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
  506.     return [list ${namespace}::$cmd ::$cmd]
  507.     }
  508. }
  509.  
  510. # auto_import --
  511. #
  512. # Invoked during "namespace import" to make see if the imported commands
  513. # reside in an autoloaded library.  If so, the commands are loaded so
  514. # that they will be available for the import links.  If not, then this
  515. # procedure does nothing.
  516. #
  517. # Arguments -
  518. # pattern    The pattern of commands being imported (like "foo::*")
  519. #               a canonical namespace as returned by [namespace current]
  520.  
  521. proc auto_import {pattern} {
  522.     global auto_index
  523.  
  524.     # If no namespace is specified, this will be an error case
  525.  
  526.     if {![string match *::* $pattern]} {
  527.     return
  528.     }
  529.  
  530.     set ns [uplevel 1 [list ::namespace current]]
  531.     set patternList [auto_qualify $pattern $ns]
  532.  
  533.     auto_load_index
  534.  
  535.     foreach pattern $patternList {
  536.         foreach name [array names auto_index $pattern] {
  537.             if {([namespace which -command $name] eq "")
  538.             && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
  539.                 namespace eval :: $auto_index($name)
  540.             }
  541.         }
  542.     }
  543. }
  544.  
  545. # auto_execok --
  546. #
  547. # Returns string that indicates name of program to execute if 
  548. # name corresponds to a shell builtin or an executable in the
  549. # Windows search path, or "" otherwise.  Builds an associative 
  550. # array auto_execs that caches information about previous checks, 
  551. # for speed.
  552. #
  553. # Arguments: 
  554. # name -            Name of a command.
  555.  
  556. if {$tcl_platform(platform) eq "windows"} {
  557. # Windows version.
  558. #
  559. # Note that info executable doesn't work under Windows, so we have to
  560. # look for files with .exe, .com, or .bat extensions.  Also, the path
  561. # may be in the Path or PATH environment variables, and path
  562. # components are separated with semicolons, not colons as under Unix.
  563. #
  564. proc auto_execok name {
  565.     global auto_execs env tcl_platform
  566.  
  567.     if {[info exists auto_execs($name)]} {
  568.     return $auto_execs($name)
  569.     }
  570.     set auto_execs($name) ""
  571.  
  572.     set shellBuiltins [list cls copy date del erase dir echo mkdir \
  573.         md rename ren rmdir rd time type ver vol]
  574.     if {$tcl_platform(os) eq "Windows NT"} {
  575.     # NT includes the 'start' built-in
  576.     lappend shellBuiltins "start"
  577.     }
  578.     if {[info exists env(PATHEXT)]} {
  579.     # Add an initial ; to have the {} extension check first.
  580.     set execExtensions [split ";$env(PATHEXT)" ";"]
  581.     } else {
  582.     set execExtensions [list {} .com .exe .bat]
  583.     }
  584.  
  585.     if {[lsearch -exact $shellBuiltins $name] != -1} {
  586.     # When this is command.com for some reason on Win2K, Tcl won't
  587.     # exec it unless the case is right, which this corrects.  COMSPEC
  588.     # may not point to a real file, so do the check.
  589.     set cmd $env(COMSPEC)
  590.     if {[file exists $cmd]} {
  591.         set cmd [file attributes $cmd -shortname]
  592.     }
  593.     return [set auto_execs($name) [list $cmd /c $name]]
  594.     }
  595.  
  596.     if {[llength [file split $name]] != 1} {
  597.     foreach ext $execExtensions {
  598.         set file ${name}${ext}
  599.         if {[file exists $file] && ![file isdirectory $file]} {
  600.         return [set auto_execs($name) [list $file]]
  601.         }
  602.     }
  603.     return ""
  604.     }
  605.  
  606.     set path "[file dirname [info nameof]];.;"
  607.     if {[info exists env(WINDIR)]} {
  608.     set windir $env(WINDIR) 
  609.     }
  610.     if {[info exists windir]} {
  611.     if {$tcl_platform(os) eq "Windows NT"} {
  612.         append path "$windir/system32;"
  613.     }
  614.     append path "$windir/system;$windir;"
  615.     }
  616.  
  617.     foreach var {PATH Path path} {
  618.     if {[info exists env($var)]} {
  619.         append path ";$env($var)"
  620.     }
  621.     }
  622.  
  623.     foreach dir [split $path {;}] {
  624.     # Skip already checked directories
  625.     if {[info exists checked($dir)] || $dir eq {}} { continue }
  626.     set checked($dir) {}
  627.     foreach ext $execExtensions {
  628.         set file [file join $dir ${name}${ext}]
  629.         if {[file exists $file] && ![file isdirectory $file]} {
  630.         return [set auto_execs($name) [list $file]]
  631.         }
  632.     }
  633.     }
  634.     return ""
  635. }
  636.  
  637. } else {
  638. # Unix version.
  639. #
  640. proc auto_execok name {
  641.     global auto_execs env
  642.  
  643.     if {[info exists auto_execs($name)]} {
  644.     return $auto_execs($name)
  645.     }
  646.     set auto_execs($name) ""
  647.     if {[llength [file split $name]] != 1} {
  648.     if {[file executable $name] && ![file isdirectory $name]} {
  649.         set auto_execs($name) [list $name]
  650.     }
  651.     return $auto_execs($name)
  652.     }
  653.     foreach dir [split $env(PATH) :] {
  654.     if {$dir eq ""} {
  655.         set dir .
  656.     }
  657.     set file [file join $dir $name]
  658.     if {[file executable $file] && ![file isdirectory $file]} {
  659.         set auto_execs($name) [list $file]
  660.         return $auto_execs($name)
  661.     }
  662.     }
  663.     return ""
  664. }
  665.  
  666. }
  667.  
  668. # ::tcl::CopyDirectory --
  669. #
  670. # This procedure is called by Tcl's core when attempts to call the
  671. # filesystem's copydirectory function fail.  The semantics of the call
  672. # are that 'dest' does not yet exist, i.e. dest should become the exact
  673. # image of src.  If dest does exist, we throw an error.  
  674. # 
  675. # Note that making changes to this procedure can change the results
  676. # of running Tcl's tests.
  677. #
  678. # Arguments: 
  679. # action -              "renaming" or "copying" 
  680. # src -            source directory
  681. # dest -        destination directory
  682. proc tcl::CopyDirectory {action src dest} {
  683.     set nsrc [file normalize $src]
  684.     set ndest [file normalize $dest]
  685.     if {$action eq "renaming"} {
  686.     # Can't rename volumes.  We could give a more precise
  687.     # error message here, but that would break the test suite.
  688.     if {[lsearch -exact [file volumes] $nsrc] != -1} {
  689.         return -code error "error $action \"$src\" to\
  690.           \"$dest\": trying to rename a volume or move a directory\
  691.           into itself"
  692.     }
  693.     }
  694.     if {[file exists $dest]} {
  695.     if {$nsrc eq $ndest} {
  696.         return -code error "error $action \"$src\" to\
  697.           \"$dest\": trying to rename a volume or move a directory\
  698.           into itself"
  699.     }
  700.     if {$action eq "copying"} {
  701.         return -code error "error $action \"$src\" to\
  702.           \"$dest\": file already exists"
  703.     } else {
  704.         # Depending on the platform, and on the current
  705.         # working directory, the directories '.', '..'
  706.         # can be returned in various combinations.  Anyway,
  707.         # if any other file is returned, we must signal an error.
  708.         set existing [glob -nocomplain -directory $dest * .*]
  709.         eval [linsert \
  710.             [glob -nocomplain -directory $dest -type hidden * .*] 0 \
  711.             lappend existing]
  712.         foreach s $existing {
  713.         if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
  714.             return -code error "error $action \"$src\" to\
  715.               \"$dest\": file already exists"
  716.         }
  717.         }
  718.     }
  719.     } else {
  720.     if {[string first $nsrc $ndest] != -1} {
  721.         set srclen [expr {[llength [file split $nsrc]] -1}]
  722.         set ndest [lindex [file split $ndest] $srclen]
  723.         if {$ndest eq [file tail $nsrc]} {
  724.         return -code error "error $action \"$src\" to\
  725.           \"$dest\": trying to rename a volume or move a directory\
  726.           into itself"
  727.         }
  728.     }
  729.     file mkdir $dest
  730.     }
  731.     # Have to be careful to capture both visible and hidden files.
  732.     # We will also be more generous to the file system and not
  733.     # assume the hidden and non-hidden lists are non-overlapping.
  734.     # 
  735.     # On Unix 'hidden' files begin with '.'.  On other platforms
  736.     # or filesystems hidden files may have other interpretations.
  737.     set filelist [concat [glob -nocomplain -directory $src *] \
  738.       [glob -nocomplain -directory $src -types hidden *]]
  739.     
  740.     foreach s [lsort -unique $filelist] {
  741.     if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
  742.         file copy $s [file join $dest [file tail $s]]
  743.     }
  744.     }
  745.     return
  746. }
  747.